home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume6 / xlisp1.6 / part3 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  47.8 KB
  1. Subject:  v06i109:  Xlisp version 1.6 (xlisp1.6), Part03/06
  2. Newsgroups: mod.sources
  3. Approved: rs@mirror.UUCP
  4.  
  5. Submitted by: seismo!utah-cs!b-davis (Brad Davis)
  6. Mod.sources: Volume 6, Issue 109
  7. Archive-name: xlisp1.6/Part03
  8.  
  9. #! /bin/sh
  10. # This is a shell archive, meaning:
  11. # 1. Remove everything above the #! /bin/sh line.
  12. # 2. Save the resulting text in a file.
  13. # 3. Execute the file with /bin/sh (not csh) to create the files:
  14. #    xlobj.c
  15. #    xlprin.c
  16. #    xlread.c
  17. #    xlstr.c
  18. #    xlsubr.c
  19. #    xlsym.c
  20. #    xlsys.c
  21. # This archive created: Mon Jul 14 10:24:06 1986
  22. export PATH; PATH=/bin:$PATH
  23. if test -f 'xlobj.c'
  24. then
  25.     echo shar: will not over-write existing file "'xlobj.c'"
  26. else
  27. cat << \SHAR_EOF > 'xlobj.c'
  28. /* xlobj - xlisp object functions */
  29. /*    Copyright (c) 1985, by David Michael Betz
  30.     All Rights Reserved
  31.     Permission is granted for unrestricted non-commercial use    */
  32.  
  33. #include "xlisp.h"
  34.  
  35. #ifdef MEGAMAX
  36. overlay "overflow"
  37. #endif
  38.  
  39. /* external variables */
  40. extern NODE ***xlstack,*xlenv;
  41. extern NODE *s_stdout;
  42. extern NODE *self,*msgclass,*msgcls,*class,*object;
  43. extern NODE *new,*isnew;
  44.  
  45. /* instance variable numbers for the class 'Class' */
  46. #define MESSAGES    0    /* list of messages */
  47. #define IVARS        1    /* list of instance variable names */
  48. #define CVARS        2    /* list of class variable names */
  49. #define CVALS        3    /* list of class variable values */
  50. #define SUPERCLASS    4    /* pointer to the superclass */
  51. #define IVARCNT        5    /* number of class instance variables */
  52. #define IVARTOTAL    6    /* total number of instance variables */
  53.  
  54. /* number of instance variables for the class 'Class' */
  55. #define CLASSSIZE    7
  56.  
  57. /* forward declarations */
  58. FORWARD NODE *entermsg();
  59. FORWARD NODE *findmsg();
  60. FORWARD NODE *sendmsg();
  61.  
  62. /* xlclass - define a class */
  63. NODE *xlclass(name,vcnt)
  64.   char *name; int vcnt;
  65. {
  66.     NODE *sym,*cls;
  67.  
  68.     /* create the class */
  69.     sym = xlsenter(name);
  70.     cls = newobject(class,CLASSSIZE);
  71.     setvalue(sym,cls);
  72.  
  73.     /* set the instance variable counts */
  74.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
  75.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
  76.  
  77.     /* set the superclass to 'Object' */
  78.     setivar(cls,SUPERCLASS,object);
  79.  
  80.     /* return the new class */
  81.     return (cls);
  82. }
  83.  
  84. /* xladdivar - enter an instance variable */
  85. xladdivar(cls,var)
  86.   NODE *cls; char *var;
  87. {
  88.     setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
  89. }
  90.  
  91. /* xladdmsg - add a message to a class */
  92. xladdmsg(cls,msg,code)
  93.   NODE *cls; char *msg; NODE *(*code)();
  94. {
  95.     NODE *mptr;
  96.  
  97.     /* enter the message selector */
  98.     mptr = entermsg(cls,xlsenter(msg));
  99.  
  100.     /* store the method for this message */
  101.     rplacd(mptr,cvsubr(code,SUBR));
  102. }
  103.  
  104. /* xlsend - send a message to an object (message in arg list) */
  105. NODE *xlsend(obj,args)
  106.   NODE *obj,*args;
  107. {
  108.     NODE ***oldstk,*arglist,*msg,*val;
  109.  
  110.     /* find the message binding for this message */
  111.     if ((msg = findmsg(getclass(obj),xlevmatch(SYM,&args))) == NIL)
  112.     xlfail("no method for this message");
  113.  
  114.     /* evaluate the arguments and send the message */
  115.     oldstk = xlsave(&arglist,(NODE **)NULL);
  116.     arglist = xlevlist(args);
  117.     val = sendmsg(obj,msg,arglist);
  118.     xlstack = oldstk;
  119.  
  120.     /* return the result */
  121.     return (val);
  122. }
  123.  
  124. /* xlobgetvalue - get the value of an instance variable */
  125. int xlobgetvalue(sym,pval)
  126.   NODE *sym,**pval;
  127. {
  128.     NODE *obj,*cls,*names;
  129.     int ivtotal,n;
  130.  
  131.     /* get the current object and the message class */
  132.     obj = xlygetvalue(self);
  133.     cls = xlygetvalue(msgclass);
  134.     if (!(objectp(obj) && objectp(cls)))
  135.     return (FALSE);
  136.  
  137.     /* find the instance or class variable */
  138.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  139.  
  140.     /* check the instance variables */
  141.     names = getivar(cls,IVARS);
  142.     ivtotal = getivcnt(cls,IVARTOTAL);
  143.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  144.         if (car(names) == sym) {
  145.         *pval = getivar(obj,n);
  146.         return (TRUE);
  147.         }
  148.         names = cdr(names);
  149.     }
  150.  
  151.     /* check the class variables */
  152.     names = getivar(cls,CVARS);
  153.     for (n = 0; consp(names); ++n) {
  154.         if (car(names) == sym) {
  155.         *pval = getelement(getivar(cls,CVALS),n);
  156.         return (TRUE);
  157.         }
  158.         names = cdr(names);
  159.     }
  160.     }
  161.  
  162.     /* variable not found */
  163.     return (FALSE);
  164. }
  165.  
  166. /* xlobsetvalue - set the value of an instance variable */
  167. int xlobsetvalue(sym,val)
  168.   NODE *sym,*val;
  169. {
  170.     NODE *obj,*cls,*names;
  171.     int ivtotal,n;
  172.  
  173.     /* get the current object and the message class */
  174.     obj = xlygetvalue(self);
  175.     cls = xlygetvalue(msgclass);
  176.     if (!(objectp(obj) && objectp(cls)))
  177.     return (FALSE);
  178.  
  179.     /* find the instance or class variable */
  180.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  181.  
  182.     /* check the instance variables */
  183.     names = getivar(cls,IVARS);
  184.     ivtotal = getivcnt(cls,IVARTOTAL);
  185.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  186.         if (car(names) == sym) {
  187.         setivar(obj,n,val);
  188.         return (TRUE);
  189.         }
  190.         names = cdr(names);
  191.     }
  192.  
  193.     /* check the class variables */
  194.     names = getivar(cls,CVARS);
  195.     for (n = 0; consp(names); ++n) {
  196.         if (car(names) == sym) {
  197.         setelement(getivar(cls,CVALS),n,val);
  198.         return (TRUE);
  199.         }
  200.         names = cdr(names);
  201.     }
  202.     }
  203.  
  204.     /* variable not found */
  205.     return (FALSE);
  206. }
  207.  
  208. /* obisnew - default 'isnew' method */
  209. LOCAL NODE *obisnew(args)
  210.   NODE *args;
  211. {
  212.     xllastarg(args);
  213.     return (xlygetvalue(self));
  214. }
  215.  
  216. /* obclass - get the class of an object */
  217. LOCAL NODE *obclass(args)
  218.   NODE *args;
  219. {
  220.     /* make sure there aren't any arguments */
  221.     xllastarg(args);
  222.  
  223.     /* return the object's class */
  224.     return (getclass(xlygetvalue(self)));
  225. }
  226.  
  227. /* obshow - show the instance variables of an object */
  228. LOCAL NODE *obshow(args)
  229.   NODE *args;
  230. {
  231.     NODE ***oldstk,*fptr,*obj,*cls,*names;
  232.     int ivtotal,n;
  233.  
  234.     /* create a new stack frame */
  235.     oldstk = xlsave(&fptr,(NODE **)NULL);
  236.  
  237.     /* get the file pointer */
  238.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  239.     xllastarg(args);
  240.  
  241.     /* get the object and its class */
  242.     obj = xlygetvalue(self);
  243.     cls = getclass(obj);
  244.  
  245.     /* print the object and class */
  246.     xlputstr(fptr,"Object is ");
  247.     xlprint(fptr,obj,TRUE);
  248.     xlputstr(fptr,", Class is ");
  249.     xlprint(fptr,cls,TRUE);
  250.     xlterpri(fptr);
  251.  
  252.     /* print the object's instance variables */
  253.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
  254.     names = getivar(cls,IVARS);
  255.     ivtotal = getivcnt(cls,IVARTOTAL);
  256.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  257.         xlputstr(fptr,"  ");
  258.         xlprint(fptr,car(names),TRUE);
  259.         xlputstr(fptr," = ");
  260.         xlprint(fptr,getivar(obj,n),TRUE);
  261.         xlterpri(fptr);
  262.         names = cdr(names);
  263.     }
  264.     }
  265.  
  266.     /* restore the previous stack frame */
  267.     xlstack = oldstk;
  268.  
  269.     /* return the object */
  270.     return (obj);
  271. }
  272.  
  273. /* obsendsuper - send a message to an object's superclass */
  274. LOCAL NODE *obsendsuper(args)
  275.   NODE *args;
  276. {
  277.     NODE *obj,*super,*msg;
  278.  
  279.     /* get the object */
  280.     obj = xlygetvalue(self);
  281.  
  282.     /* get the object's superclass */
  283.     super = getivar(getclass(obj),SUPERCLASS);
  284.  
  285.     /* find the message binding for this message */
  286.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  287.     xlfail("no method for this message");
  288.  
  289.     /* send the message */
  290.     return (sendmsg(obj,msg,args));
  291. }
  292.  
  293. /* clnew - create a new object instance */
  294. LOCAL NODE *clnew()
  295. {
  296.     NODE *cls;
  297.     cls = xlygetvalue(self);
  298.     return (newobject(cls,getivcnt(cls,IVARTOTAL)));
  299. }
  300.  
  301. /* clisnew - initialize a new class */
  302. LOCAL NODE *clisnew(args)
  303.   NODE *args;
  304. {
  305.     NODE *ivars,*cvars,*super,*cls;
  306.     int n;
  307.  
  308.     /* get the ivars, cvars and superclass */
  309.     ivars = xlmatch(LIST,&args);
  310.     cvars = (args ? xlmatch(LIST,&args) : NIL);
  311.     super = (args ? xlmatch(OBJ,&args) : object);
  312.     xllastarg(args);
  313.  
  314.     /* get the new class object */
  315.     cls = xlygetvalue(self);
  316.  
  317.     /* store the instance and class variable lists and the superclass */
  318.     setivar(cls,IVARS,ivars);
  319.     setivar(cls,CVARS,cvars);
  320.     setivar(cls,CVALS,newvector(listlength(cvars)));
  321.     setivar(cls,SUPERCLASS,super);
  322.  
  323.     /* compute the instance variable count */
  324.     n = listlength(ivars);
  325.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
  326.     n += getivcnt(super,IVARTOTAL);
  327.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
  328.  
  329.     /* return the new class object */
  330.     return (cls);
  331. }
  332.  
  333. /* clanswer - define a method for answering a message */
  334. LOCAL NODE *clanswer(args)
  335.   NODE *args;
  336. {
  337.     NODE ***oldstk,*arg,*msg,*fargs,*code,*obj,*mptr;
  338.  
  339.     /* create a new stack frame */
  340.     oldstk = xlsave(&arg,&msg,&fargs,&code,(NODE **)NULL);
  341.  
  342.     /* initialize */
  343.     arg = args;
  344.  
  345.     /* message symbol, formal argument list and code */
  346.     msg = xlmatch(SYM,&arg);
  347.     fargs = xlmatch(LIST,&arg);
  348.     code = xlmatch(LIST,&arg);
  349.     xllastarg(arg);
  350.  
  351.     /* get the object node */
  352.     obj = xlygetvalue(self);
  353.  
  354.     /* make a new message list entry */
  355.     mptr = entermsg(obj,msg);
  356.  
  357.     /* setup the message node */
  358.     rplacd(mptr,cons(fargs,code));
  359.  
  360.     /* restore the previous stack frame */
  361.     xlstack = oldstk;
  362.  
  363.     /* return the object */
  364.     return (obj);
  365. }
  366.  
  367. /* entermsg - add a message to a class */
  368. LOCAL NODE *entermsg(cls,msg)
  369.   NODE *cls,*msg;
  370. {
  371.     NODE ***oldstk,*lptr,*mptr;
  372.  
  373.     /* lookup the message */
  374.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  375.     if (car(mptr = car(lptr)) == msg)
  376.         return (mptr);
  377.  
  378.     /* allocate a new message entry if one wasn't found */
  379.     oldstk = xlsave(&mptr,(NODE **)NULL);
  380.     mptr = consa(msg);
  381.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  382.     xlstack = oldstk;
  383.  
  384.     /* return the symbol node */
  385.     return (mptr);
  386. }
  387.  
  388. /* findmsg - find the message binding given an object and a class */
  389. LOCAL NODE *findmsg(cls,sym)
  390.   NODE *cls,*sym;
  391. {
  392.     NODE *lptr,*msg;
  393.  
  394.     /* look for the message in the class or superclasses */
  395.     for (msgcls = cls; msgcls != NIL; ) {
  396.  
  397.     /* lookup the message in this class */
  398.     for (lptr = getivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
  399.         if ((msg = car(lptr)) != NIL && car(msg) == sym)
  400.         return (msg);
  401.  
  402.     /* look in class's superclass */
  403.     msgcls = getivar(msgcls,SUPERCLASS);
  404.     }
  405.  
  406.     /* message not found */
  407.     return (NIL);
  408. }
  409.  
  410. /* sendmsg - send a message to an object */
  411. LOCAL NODE *sendmsg(obj,msg,args)
  412.   NODE *obj,*msg,*args;
  413. {
  414.     NODE ***oldstk,*oldenv,*newenv,*method,*cptr,*val,*isnewmsg;
  415.  
  416.     /* create a new stack frame */
  417.     oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,(NODE **)NULL);
  418.  
  419.     /* get the method for this message */
  420.     method = cdr(msg);
  421.  
  422.     /* make sure its a function or a subr */
  423.     if (!subrp(method) && !consp(method))
  424.     xlfail("bad method");
  425.  
  426.     /* create a new environment frame */
  427.     newenv = xlframe(NIL);
  428.     oldenv = xlenv;
  429.  
  430.     /* bind the symbols 'self' and 'msgclass' */
  431.     xlbind(self,obj,newenv);
  432.     xlbind(msgclass,msgcls,newenv);
  433.  
  434.     /* evaluate the function call */
  435.     if (subrp(method)) {
  436.     xlenv = newenv;
  437.     val = (*getsubr(method))(args);
  438.     }
  439.     else {
  440.  
  441.     /* bind the formal arguments */
  442.     xlabind(car(method),args,newenv);
  443.     xlenv = newenv;
  444.  
  445.     /* execute the code */
  446.     cptr = cdr(method);
  447.     while (cptr)
  448.         val = xlevarg(&cptr);
  449.     }
  450.  
  451.     /* restore the environment */
  452.     xlenv = oldenv;
  453.  
  454.     /* after creating an object, send it the "isnew" message */
  455.     if (car(msg) == new && val) {
  456.     if ((isnewmsg = findmsg(getclass(val),isnew)) == NIL)
  457.         xlfail("no method for the isnew message");
  458.     sendmsg(val,isnewmsg,args);
  459.     }
  460.  
  461.     /* restore the previous stack frame */
  462.     xlstack = oldstk;
  463.  
  464.     /* return the result value */
  465.     return (val);
  466. }
  467.  
  468. /* getivcnt - get the number of instance variables for a class */
  469. LOCAL int getivcnt(cls,ivar)
  470.   NODE *cls; int ivar;
  471. {
  472.     NODE *cnt;
  473.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  474.     xlfail("bad value for instance variable count");
  475.     return ((int)getfixnum(cnt));
  476. }
  477.  
  478. /* listlength - find the length of a list */
  479. LOCAL int listlength(list)
  480.   NODE *list;
  481. {
  482.     int len;
  483.     for (len = 0; consp(list); len++)
  484.     list = cdr(list);
  485.     return (len);
  486. }
  487.  
  488. /* xloinit - object function initialization routine */
  489. xloinit()
  490. {
  491.     /* don't confuse the garbage collector */
  492.     class = object = NIL;
  493.  
  494.     /* enter the object related symbols */
  495.     self    = xlsenter("SELF");
  496.     msgclass    = xlsenter("MSGCLASS");
  497.     new        = xlsenter(":NEW");
  498.     isnew    = xlsenter(":ISNEW");
  499.  
  500.     /* create the 'Class' object */
  501.     class = xlclass("CLASS",CLASSSIZE);
  502.     setelement(class,0,class);
  503.  
  504.     /* create the 'Object' object */
  505.     object = xlclass("OBJECT",0);
  506.  
  507.     /* finish initializing 'class' */
  508.     setivar(class,SUPERCLASS,object);
  509.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  510.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  511.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  512.     xladdivar(class,"CVALS");        /* ivar number 3 */
  513.     xladdivar(class,"CVARS");        /* ivar number 2 */
  514.     xladdivar(class,"IVARS");        /* ivar number 1 */
  515.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  516.     xladdmsg(class,":NEW",clnew);
  517.     xladdmsg(class,":ISNEW",clisnew);
  518.     xladdmsg(class,":ANSWER",clanswer);
  519.  
  520.     /* finish initializing 'object' */
  521.     xladdmsg(object,":ISNEW",obisnew);
  522.     xladdmsg(object,":CLASS",obclass);
  523.     xladdmsg(object,":SHOW",obshow);
  524.     xladdmsg(object,":SENDSUPER",obsendsuper);
  525. }
  526.  
  527. SHAR_EOF
  528. fi # end of overwriting check
  529. if test -f 'xlprin.c'
  530. then
  531.     echo shar: will not over-write existing file "'xlprin.c'"
  532. else
  533. cat << \SHAR_EOF > 'xlprin.c'
  534. /* xlprint - xlisp print routine */
  535. /*    Copyright (c) 1985, by David Michael Betz
  536.     All Rights Reserved
  537.     Permission is granted for unrestricted non-commercial use    */
  538.  
  539. #include "xlisp.h"
  540.  
  541. #ifdef MEGAMAX
  542. overlay "io"
  543. #endif
  544.  
  545. /* external variables */
  546. extern char buf[];
  547.  
  548. /* xlprint - print an xlisp value */
  549. void xlprint(fptr,vptr,flag)
  550.   NODE *fptr,*vptr; int flag;
  551. {
  552.     NODE *nptr;
  553.     NODE *next = NIL;
  554.     int n,i;
  555.  
  556.     /* print nil */
  557.     if (vptr == NIL) {
  558.     xlputstr(fptr,"NIL");
  559.     return;
  560.     }
  561.  
  562.     /* check value type */
  563.     switch (ntype(vptr)) {
  564.     case SUBR:
  565.         putatm(fptr,"Subr",vptr);
  566.         break;
  567.     case FSUBR:
  568.         putatm(fptr,"FSubr",vptr);
  569.         break;
  570.     case LIST:
  571.         xlputc(fptr,'(');
  572.         for (nptr = vptr; nptr != NIL; nptr = next) {
  573.             xlprint(fptr,car(nptr),flag);
  574.         if (next = cdr(nptr))
  575.             if (consp(next))
  576.             xlputc(fptr,' ');
  577.             else {
  578.             xlputstr(fptr," . ");
  579.             xlprint(fptr,next,flag);
  580.             break;
  581.             }
  582.         }
  583.         xlputc(fptr,')');
  584.         break;
  585.     case SYM:
  586.         xlputstr(fptr,getstring(getpname(vptr)));
  587.         break;
  588.     case INT:
  589.         putdec(fptr,getfixnum(vptr));
  590.         break;
  591.     case FLOAT:
  592.         putfloat(fptr,getflonum(vptr));
  593.         break;
  594.     case STR:
  595.         if (flag)
  596.         putstring(fptr,getstring(vptr));
  597.         else
  598.         xlputstr(fptr,getstring(vptr));
  599.         break;
  600.     case FPTR:
  601.         putatm(fptr,"File",vptr);
  602.         break;
  603.     case OBJ:
  604.         putatm(fptr,"Object",vptr);
  605.         break;
  606.     case VECT:
  607.         xlputc(fptr,'#'); xlputc(fptr,'(');
  608.         for (i = 0, n = getsize(vptr); n-- > 0; ) {
  609.         xlprint(fptr,getelement(vptr,i++),flag);
  610.         if (n) xlputc(fptr,' ');
  611.         }
  612.         xlputc(fptr,')');
  613.         break;
  614.     case FREE:
  615.         putatm(fptr,"Free",vptr);
  616.         break;
  617.     default:
  618.         putatm(fptr,"Foo",vptr);
  619.         break;
  620.     }
  621. }
  622.  
  623. /* xlterpri - terminate the current print line */
  624. xlterpri(fptr)
  625.   NODE *fptr;
  626. {
  627.     xlputc(fptr,'\n');
  628. }
  629.  
  630. /* xlputstr - output a string */
  631. xlputstr(fptr,str)
  632.   NODE *fptr; char *str;
  633. {
  634.     while (*str)
  635.     xlputc(fptr,*str++);
  636. }
  637.  
  638. /* putstring - output a string */
  639. LOCAL putstring(fptr,str)
  640.   NODE *fptr; char *str;
  641. {
  642.     int ch;
  643.  
  644.     /* output the initial quote */
  645.     xlputc(fptr,'"');
  646.  
  647.     /* output each character in the string */
  648.     while (ch = *str++)
  649.  
  650.     /* check for a control character */
  651.     if (ch < 040 || ch == '\\') {
  652.         xlputc(fptr,'\\');
  653.         switch (ch) {
  654.         case '\033':
  655.             xlputc(fptr,'e');
  656.             break;
  657.         case '\n':
  658.             xlputc(fptr,'n');
  659.             break;
  660.         case '\r':
  661.             xlputc(fptr,'r');
  662.             break;
  663.         case '\t':
  664.             xlputc(fptr,'t');
  665.             break;
  666.         case '\\':
  667.             xlputc(fptr,'\\');
  668.             break;
  669.         default:
  670.             putoct(fptr,ch);
  671.             break;
  672.         }
  673.     }
  674.  
  675.     /* output a normal character */
  676.     else
  677.         xlputc(fptr,ch);
  678.  
  679.     /* output the terminating quote */
  680.     xlputc(fptr,'"');
  681. }
  682.  
  683. /* putatm - output an atom */
  684. LOCAL putatm(fptr,tag,val)
  685.   NODE *fptr; char *tag; NODE *val;
  686. {
  687.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  688.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  689.     xlputc(fptr,'>');
  690. }
  691.  
  692. /* putdec - output a decimal number */
  693. LOCAL putdec(fptr,n)
  694.   NODE *fptr; FIXNUM n;
  695. {
  696.     sprintf(buf,IFMT,n);
  697.     xlputstr(fptr,buf);
  698. }
  699.  
  700. /* putfloat - output a floating point number */
  701. LOCAL putfloat(fptr,n)
  702.   NODE *fptr; FLONUM n;
  703. {
  704.     sprintf(buf,"%g",n);
  705.     xlputstr(fptr,buf);
  706. }
  707.  
  708. /* putoct - output an octal byte value */
  709. LOCAL putoct(fptr,n)
  710.   NODE *fptr; int n;
  711. {
  712.     sprintf(buf,"%03o",n);
  713.     xlputstr(fptr,buf);
  714. }
  715.  
  716. SHAR_EOF
  717. fi # end of overwriting check
  718. if test -f 'xlread.c'
  719. then
  720.     echo shar: will not over-write existing file "'xlread.c'"
  721. else
  722. cat << \SHAR_EOF > 'xlread.c'
  723. /* xlread - xlisp expression input routine */
  724. /*    Copyright (c) 1985, by David Michael Betz
  725.     All Rights Reserved
  726.     Permission is granted for unrestricted non-commercial use    */
  727.  
  728. #include "xlisp.h"
  729.  
  730. #ifdef MEGAMAX
  731. overlay "io"
  732. #endif
  733.  
  734. /* external variables */
  735. extern NODE *s_stdout,*true,*s_dot;
  736. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  737. extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
  738. extern NODE ***xlstack;
  739. extern int xlplevel;
  740. extern char buf[];
  741.  
  742. /* external routines */
  743. extern FILE *fopen();
  744. extern double atof();
  745. extern ITYPE;
  746.  
  747. #define WSPACE "\t \f\r\n"
  748. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  749. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  750.  
  751. /* forward declarations */
  752. FORWARD NODE *callmacro();
  753. FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
  754. FORWARD NODE *tentry();
  755.  
  756. /* xlload - load a file of xlisp expressions */
  757. int xlload(fname,vflag,pflag)
  758.   char *fname; int vflag,pflag;
  759. {
  760.     NODE ***oldstk,*fptr,*expr;
  761.     char fullname[STRMAX+1];
  762.     CONTEXT cntxt;
  763.     FILE *fp;
  764.     int sts;
  765.  
  766.     /* create a new stack frame */
  767.     oldstk = xlsave(&fptr,&expr,(NODE **)NULL);
  768.  
  769.     /* create the full file name */
  770.     if (needsextension(fname)) {
  771.     strcpy(fullname,fname);
  772.     strcat(fullname,".lsp");
  773.     fname = fullname;
  774.     }
  775.  
  776.     /* allocate a file node */
  777.     fptr = cvfile(NULL);
  778.  
  779.     /* print the information line */
  780.     if (vflag)
  781.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  782.  
  783.     /* open the file */
  784.     if ((fp = fopen(fname,"r")) == NULL) {
  785.     xlstack = oldstk;
  786.     return (FALSE);
  787.     }
  788.     setfile(fptr,fp);
  789.  
  790.     /* read, evaluate and possibly print each expression in the file */
  791.     xlbegin(&cntxt,CF_ERROR,true);
  792.     if (setjmp(cntxt.c_jmpbuf))
  793.     sts = FALSE;
  794.     else {
  795.     while (xlread(fptr,&expr,FALSE)) {
  796.         expr = xleval(expr);
  797.         if (pflag)
  798.         stdprint(expr);
  799.     }
  800.     sts = TRUE;
  801.     }
  802.     xlend(&cntxt);
  803.  
  804.     /* close the file */
  805.     fclose(getfile(fptr));
  806.     setfile(fptr,NULL);
  807.  
  808.     /* restore the previous stack frame */
  809.     xlstack = oldstk;
  810.  
  811.     /* return status */
  812.     return (sts);
  813. }
  814.  
  815. /* xlread - read an xlisp expression */
  816. int xlread(fptr,pval,rflag)
  817.   NODE *fptr,**pval; int rflag;
  818. {
  819.     int sts;
  820.  
  821.     /* reset the paren nesting level */
  822.     if (!rflag)
  823.     xlplevel = 0;
  824.  
  825.     /* read an expression */
  826.     while ((sts = readone(fptr,pval)) == FALSE)
  827.     ;
  828.  
  829.     /* return status */
  830.     return (sts == EOF ? FALSE : TRUE);
  831. }
  832.  
  833. /* readone - attempt to read a single expression */
  834. int readone(fptr,pval)
  835.   NODE *fptr,**pval;
  836. {
  837.     NODE *val,*type;
  838.     int ch;
  839.  
  840.     /* get a character and check for EOF */
  841.     if ((ch = xlgetc(fptr)) == EOF)
  842.     return (EOF);
  843.  
  844.     /* handle white space */
  845.     if ((type = tentry(ch)) == k_wspace)
  846.     return (FALSE);
  847.  
  848.     /* handle symbol constituents */
  849.     else if (type == k_const) {
  850.     *pval = pname(fptr,ch);
  851.     return (TRUE);
  852.     }
  853.  
  854.     /* handle read macros */
  855.     else if (consp(type)) {
  856.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  857.         *pval = car(val);
  858.         return (TRUE);
  859.     }
  860.     else
  861.         return (FALSE);
  862.     }
  863.  
  864.     /* handle illegal characters */
  865.     else
  866.     xlerror("illegal character",cvfixnum((FIXNUM)ch));
  867.     /*NOTREACHED*/
  868. }
  869.  
  870. /* rmhash - read macro for '#' */
  871. NODE *rmhash(args)
  872.   NODE *args;
  873. {
  874.     NODE ***oldstk,*fptr,*mch,*val;
  875.     int ch;
  876.  
  877.     /* create a new stack frame */
  878.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  879.  
  880.     /* get the file and macro character */
  881.     fptr = xlgetfile(&args);
  882.     mch = xlmatch(INT,&args);
  883.     xllastarg(args);
  884.  
  885.     /* make the return value */
  886.     val = consa(NIL);
  887.  
  888.     /* check the next character */
  889.     switch (ch = xlgetc(fptr)) {
  890.     case '\'':
  891.         rplaca(val,pquote(fptr,s_function));
  892.         break;
  893.     case '(':
  894.         rplaca(val,pvector(fptr));
  895.         break;
  896.     case 'x':
  897.     case 'X':
  898.             rplaca(val,phexnumber(fptr));
  899.         break;
  900.     case '\\':
  901.         rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
  902.         break;
  903.     default:
  904.         xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
  905.     }
  906.  
  907.     /* restore the previous stack frame */
  908.     xlstack = oldstk;
  909.  
  910.     /* return the value */
  911.     return (val);
  912. }
  913.  
  914. /* rmquote - read macro for '\'' */
  915. NODE *rmquote(args)
  916.   NODE *args;
  917. {
  918.     NODE ***oldstk,*fptr,*mch,*val;
  919.  
  920.     /* create a new stack frame */
  921.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  922.  
  923.     /* get the file and macro character */
  924.     fptr = xlgetfile(&args);
  925.     mch = xlmatch(INT,&args);
  926.     xllastarg(args);
  927.  
  928.     /* make the return value */
  929.     val = consa(NIL);
  930.     rplaca(val,pquote(fptr,s_quote));
  931.  
  932.     /* restore the previous stack frame */
  933.     xlstack = oldstk;
  934.  
  935.     /* return the value */
  936.     return (val);
  937. }
  938.  
  939. /* rmdquote - read macro for '"' */
  940. NODE *rmdquote(args)
  941.   NODE *args;
  942. {
  943.     NODE ***oldstk,*fptr,*mch,*val;
  944.     int ch,i,d1,d2,d3;
  945.  
  946.     /* create a new stack frame */
  947.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  948.  
  949.     /* get the file and macro character */
  950.     fptr = xlgetfile(&args);
  951.     mch = xlmatch(INT,&args);
  952.     xllastarg(args);
  953.  
  954.     /* loop looking for a closing quote */
  955.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  956.     switch (ch) {
  957.     case '\\':
  958.         switch (ch = checkeof(fptr)) {
  959.         case 'f':
  960.             ch = '\f';
  961.             break;
  962.         case 'n':
  963.             ch = '\n';
  964.             break;
  965.         case 'r':
  966.             ch = '\r';
  967.             break;
  968.         case 't':
  969.             ch = '\t';
  970.             break;
  971.         default:
  972.             if (ch >= '0' && ch <= '7') {
  973.                 d1 = ch - '0';
  974.                 d2 = checkeof(fptr) - '0';
  975.                 d3 = checkeof(fptr) - '0';
  976.                 ch = (d1 << 6) + (d2 << 3) + d3;
  977.             }
  978.             break;
  979.         }
  980.     }
  981.     buf[i] = ch;
  982.     }
  983.     buf[i] = 0;
  984.  
  985.     /* initialize the node */
  986.     val = consa(NIL);
  987.     rplaca(val,cvstring(buf));
  988.  
  989.     /* restore the previous stack frame */
  990.     xlstack = oldstk;
  991.  
  992.     /* return the new string */
  993.     return (val);
  994. }
  995.  
  996. /* rmbquote - read macro for '`' */
  997. NODE *rmbquote(args)
  998.   NODE *args;
  999. {
  1000.     NODE ***oldstk,*fptr,*mch,*val;
  1001.  
  1002.     /* create a new stack frame */
  1003.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  1004.  
  1005.     /* get the file and macro character */
  1006.     fptr = xlgetfile(&args);
  1007.     mch = xlmatch(INT,&args);
  1008.     xllastarg(args);
  1009.  
  1010.     /* make the return value */
  1011.     val = consa(NIL);
  1012.     rplaca(val,pquote(fptr,s_bquote));
  1013.  
  1014.     /* restore the previous stack frame */
  1015.     xlstack = oldstk;
  1016.  
  1017.     /* return the value */
  1018.     return (val);
  1019. }
  1020.  
  1021. /* rmcomma - read macro for ',' */
  1022. NODE *rmcomma(args)
  1023.   NODE *args;
  1024. {
  1025.     NODE ***oldstk,*fptr,*mch,*val,*sym;
  1026.  
  1027.     /* create a new stack frame */
  1028.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  1029.  
  1030.     /* get the file and macro character */
  1031.     fptr = xlgetfile(&args);
  1032.     mch = xlmatch(INT,&args);
  1033.     xllastarg(args);
  1034.  
  1035.     /* check the next character */
  1036.     if (xlpeek(fptr) == '@') {
  1037.     sym = s_comat;
  1038.     xlgetc(fptr);
  1039.     }
  1040.     else
  1041.     sym = s_comma;
  1042.  
  1043.     /* make the return value */
  1044.     val = consa(NIL);
  1045.     rplaca(val,pquote(fptr,sym));
  1046.  
  1047.     /* restore the previous stack frame */
  1048.     xlstack = oldstk;
  1049.  
  1050.     /* return the value */
  1051.     return (val);
  1052. }
  1053.  
  1054. /* rmlpar - read macro for '(' */
  1055. NODE *rmlpar(args)
  1056.   NODE *args;
  1057. {
  1058.     NODE ***oldstk,*fptr,*mch,*val;
  1059.  
  1060.     /* create a new stack frame */
  1061.     oldstk = xlsave(&fptr,&mch,&val,(NODE **)NULL);
  1062.  
  1063.     /* get the file and macro character */
  1064.     fptr = xlgetfile(&args);
  1065.     mch = xlmatch(INT,&args);
  1066.     xllastarg(args);
  1067.  
  1068.     /* make the return value */
  1069.     val = consa(NIL);
  1070.     rplaca(val,plist(fptr));
  1071.  
  1072.     /* restore the previous stack frame */
  1073.     xlstack = oldstk;
  1074.  
  1075.     /* return the value */
  1076.     return (val);
  1077. }
  1078.  
  1079. /* rmrpar - read macro for ')' */
  1080. NODE *rmrpar(args)
  1081.   NODE *args;
  1082. {
  1083.     xlfail("misplaced right paren");
  1084. }
  1085.  
  1086. /* rmsemi - read macro for ';' */
  1087. NODE *rmsemi(args)
  1088.   NODE *args;
  1089. {
  1090.     NODE ***oldstk,*fptr,*mch;
  1091.     int ch;
  1092.  
  1093.     /* create a new stack frame */
  1094.     oldstk = xlsave(&fptr,&mch,(NODE **)NULL);
  1095.  
  1096.     /* get the file and macro character */
  1097.     fptr = xlgetfile(&args);
  1098.     mch = xlmatch(INT,&args);
  1099.     xllastarg(args);
  1100.  
  1101.     /* skip to end of line */
  1102.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  1103.     ;
  1104.  
  1105.     /* restore the previous stack frame */
  1106.     xlstack = oldstk;
  1107.  
  1108.     /* return nil (nothing read) */
  1109.     return (NIL);
  1110. }
  1111.  
  1112. /* phexnumber - parse a hexidecimal number */
  1113. LOCAL NODE *phexnumber(fptr)
  1114.   NODE *fptr;
  1115. {
  1116.     long num;
  1117.     int ch;
  1118.     
  1119.     num = 0L;
  1120.     while ((ch = xlpeek(fptr)) != EOF) {
  1121.     if (islower(ch)) ch = toupper(ch);
  1122.     if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
  1123.         break;
  1124.     xlgetc(fptr);
  1125.     num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
  1126.     }
  1127.     return (cvfixnum((FIXNUM)num));
  1128. }
  1129.  
  1130. /* plist - parse a list */
  1131. LOCAL NODE *plist(fptr)
  1132.   NODE *fptr;
  1133. {
  1134.     NODE ***oldstk,*val,*expr,*lastnptr;
  1135.     NODE *nptr = NIL;
  1136.  
  1137.     /* create a new stack frame */
  1138.     oldstk = xlsave(&val,&expr,(NODE **)NULL);
  1139.  
  1140.     /* increase the paren nesting level */
  1141.     ++xlplevel;
  1142.  
  1143.     /* keep appending nodes until a closing paren is found */
  1144.     lastnptr = NIL;
  1145.     for (lastnptr = NIL; nextch(fptr) != ')'; lastnptr = nptr)
  1146.  
  1147.     /* get the next expression */
  1148.     switch (readone(fptr,&expr)) {
  1149.     case EOF:
  1150.         badeof(fptr);
  1151.     case TRUE:
  1152.  
  1153.         /* check for a dotted tail */
  1154.         if (expr == s_dot) {
  1155.  
  1156.         /* make sure there's a node */
  1157.         if (lastnptr == NIL)
  1158.             xlfail("invalid dotted pair");
  1159.  
  1160.         /* parse the expression after the dot */
  1161.         if (!xlread(fptr,&expr,TRUE))
  1162.             badeof(fptr);
  1163.         rplacd(lastnptr,expr);
  1164.  
  1165.         /* make sure its followed by a close paren */
  1166.         if (nextch(fptr) != ')')
  1167.             xlfail("invalid dotted pair");
  1168.  
  1169.         /* done with this list */
  1170.         break;
  1171.         }
  1172.  
  1173.         /* otherwise, handle a normal list element */
  1174.         else {
  1175.         nptr = consa(expr);
  1176.         if (lastnptr == NIL)
  1177.             val = nptr;
  1178.         else
  1179.             rplacd(lastnptr,nptr);
  1180.         }
  1181.         break;
  1182.     }
  1183.  
  1184.     /* skip the closing paren */
  1185.     xlgetc(fptr);
  1186.  
  1187.     /* decrease the paren nesting level */
  1188.     --xlplevel;
  1189.  
  1190.     /* restore the previous stack frame */
  1191.     xlstack = oldstk;
  1192.  
  1193.     /* return successfully */
  1194.     return (val);
  1195. }
  1196.  
  1197. /* pvector - parse a vector */
  1198. LOCAL NODE *pvector(fptr)
  1199.   NODE *fptr;
  1200. {
  1201.     NODE ***oldstk,*list,*expr,*val,*lastnptr;
  1202.     NODE *nptr = NIL;
  1203.     int len,ch,i;
  1204.  
  1205.     /* create a new stack frame */
  1206.     oldstk = xlsave(&list,&expr,(NODE **)NULL);
  1207.  
  1208.     /* keep appending nodes until a closing paren is found */
  1209.     lastnptr = NIL; len = 0;
  1210.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  1211.  
  1212.     /* check for end of file */
  1213.     if (ch == EOF)
  1214.         badeof(fptr);
  1215.  
  1216.     /* get the next expression */
  1217.     switch (readone(fptr,&expr)) {
  1218.     case EOF:
  1219.         badeof(fptr);
  1220.     case TRUE:
  1221.         nptr = consa(expr);
  1222.         if (lastnptr == NIL)
  1223.         list = nptr;
  1224.         else
  1225.         rplacd(lastnptr,nptr);
  1226.         len++;
  1227.         break;
  1228.     }
  1229.     }
  1230.  
  1231.     /* skip the closing paren */
  1232.     xlgetc(fptr);
  1233.  
  1234.     /* make a vector of the appropriate length */
  1235.     val = newvector(len);
  1236.  
  1237.     /* copy the list into the vector */
  1238.     for (i = 0; i < len; ++i, list = cdr(list))
  1239.     setelement(val,i,car(list));
  1240.  
  1241.     /* restore the previous stack frame */
  1242.     xlstack = oldstk;
  1243.  
  1244.     /* return successfully */
  1245.     return (val);
  1246. }
  1247.  
  1248. /* pquote - parse a quoted expression */
  1249. LOCAL NODE *pquote(fptr,sym)
  1250.   NODE *fptr,*sym;
  1251. {
  1252.     NODE ***oldstk,*val,*p;
  1253.  
  1254.     /* create a new stack frame */
  1255.     oldstk = xlsave(&val,(NODE **)NULL);
  1256.  
  1257.     /* allocate two nodes */
  1258.     val = consa(sym);
  1259.     rplacd(val,consa(NIL));
  1260.  
  1261.     /* initialize the second to point to the quoted expression */
  1262.     if (!xlread(fptr,&p,TRUE))
  1263.     badeof(fptr);
  1264.     rplaca(cdr(val),p);
  1265.  
  1266.     /* restore the previous stack frame */
  1267.     xlstack = oldstk;
  1268.  
  1269.     /* return the quoted expression */
  1270.     return (val);
  1271. }
  1272.  
  1273. /* pname - parse a symbol name */
  1274. LOCAL NODE *pname(fptr,ch)
  1275.   NODE *fptr; int ch;
  1276. {
  1277.     NODE *val,*type;
  1278.     int i;
  1279.  
  1280.     /* get symbol name */
  1281.     for (i = 0; ; xlgetc(fptr)) {
  1282.     if (i < STRMAX)
  1283.         buf[i++] = (islower(ch) ? toupper(ch) : ch);
  1284.     if ((ch = xlpeek(fptr)) == EOF ||
  1285.         ((type = tentry(ch)) != k_const &&
  1286.              !(consp(type) && car(type) == k_nmacro)))
  1287.         break;
  1288.     }
  1289.     buf[i] = 0;
  1290.  
  1291.     /* check for a number or enter the symbol into the oblist */
  1292.     return (isnumber(buf,&val) ? val : xlenter(buf,DYNAMIC));
  1293. }
  1294.  
  1295. /* tentry - get a readtable entry */
  1296. LOCAL NODE *tentry(ch)
  1297.   int ch;
  1298. {
  1299.     NODE *rtable;
  1300.     rtable = getvalue(s_rtable);
  1301.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  1302.     return (NIL);
  1303.     return (getelement(rtable,ch));
  1304. }
  1305.  
  1306. /* nextch - look at the next non-blank character */
  1307. LOCAL int nextch(fptr)
  1308.   NODE *fptr;
  1309. {
  1310.     int ch;
  1311.  
  1312.     /* return and save the next non-blank character */
  1313.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  1314.     xlgetc(fptr);
  1315.     return (ch);
  1316. }
  1317.  
  1318. /* checkeof - get a character and check for end of file */
  1319. LOCAL int checkeof(fptr)
  1320.   NODE *fptr;
  1321. {
  1322.     int ch;
  1323.  
  1324.     if ((ch = xlgetc(fptr)) == EOF)
  1325.     badeof(fptr);
  1326.     return (ch);
  1327. }
  1328.  
  1329. /* badeof - unexpected eof */
  1330. LOCAL badeof(fptr)
  1331.   NODE *fptr;
  1332. {
  1333.     xlgetc(fptr);
  1334.     xlfail("unexpected EOF");
  1335. }
  1336.  
  1337. /* isnumber - check if this string is a number */
  1338. int isnumber(str,pval)
  1339.   char *str; NODE **pval;
  1340. {
  1341.     int dl,dr;
  1342.     char *p;
  1343.  
  1344.     /* initialize */
  1345.     p = str; dl = dr = 0;
  1346.  
  1347.     /* check for a sign */
  1348.     if (*p == '+' || *p == '-')
  1349.     p++;
  1350.  
  1351.     /* check for a string of digits */
  1352.     while (isdigit(*p))
  1353.     p++, dl++;
  1354.  
  1355.     /* check for a decimal point */
  1356.     if (*p == '.') {
  1357.     p++;
  1358.     while (isdigit(*p))
  1359.         p++, dr++;
  1360.     }
  1361.  
  1362.     /* check for an exponent */
  1363.     if ((dl || dr) && *p == 'E') {
  1364.     p++;
  1365.  
  1366.     /* check for a sign */
  1367.     if (*p == '+' || *p == '-')
  1368.         p++;
  1369.  
  1370.     /* check for a string of digits */
  1371.     while (isdigit(*p))
  1372.         p++, dr++;
  1373.     }
  1374.  
  1375.     /* make sure there was at least one digit and this is the end */
  1376.     if ((dl == 0 && dr == 0) || *p)
  1377.     return (FALSE);
  1378.  
  1379.     /* convert the string to an integer and return successfully */
  1380.     if (*str == '+') ++str;
  1381.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  1382.     *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  1383.     return (TRUE);
  1384. }
  1385.  
  1386. /* defmacro - define a read macro */
  1387. defmacro(ch,type,fun)
  1388.   int ch; NODE *type,*(*fun)();
  1389. {
  1390.     NODE *p;
  1391.     p = consa(type);
  1392.     setelement(getvalue(s_rtable),ch,p);
  1393.     rplacd(p,cvsubr(fun,SUBR));
  1394. }
  1395.  
  1396. /* callmacro - call a read macro */
  1397. NODE *callmacro(fptr,ch)
  1398.   NODE *fptr; int ch;
  1399. {
  1400.     NODE ***oldstk,*fun,*args,*val;
  1401.  
  1402.     /* create a new stack frame */
  1403.     oldstk = xlsave(&fun,&args,(NODE **)NULL);
  1404.  
  1405.     /* get the macro function */
  1406.     fun = cdr(getelement(getvalue(s_rtable),ch));
  1407.  
  1408.     /* create the argument list */
  1409.     args = consa(fptr);
  1410.     rplacd(args,consa(NIL));
  1411.     rplaca(cdr(args),cvfixnum((FIXNUM)ch));
  1412.  
  1413.     /* apply the macro function to the arguments */
  1414.     val = xlapply(fun,args);
  1415.  
  1416.     /* restore the previous stack frame */
  1417.     xlstack = oldstk;
  1418.  
  1419.     /* return the result */
  1420.     return (val);
  1421. }
  1422.  
  1423. /* needsextension - determine if a filename needs an extension */
  1424. int needsextension(name)
  1425.   char *name;
  1426. {
  1427.     while (*name)
  1428.     if (*name++ == '.')
  1429.         return (FALSE);
  1430.     return (TRUE);
  1431. }
  1432.  
  1433. /* xlrinit - initialize the reader */
  1434. xlrinit()
  1435. {
  1436.     NODE *rtable;
  1437.     char *p;
  1438.     int ch;
  1439.  
  1440.     /* create the read table */
  1441.     rtable = newvector(256);
  1442.     setvalue(s_rtable,rtable);
  1443.  
  1444.     /* initialize the readtable */
  1445.     for (p = WSPACE; ch = *p++; )
  1446.     setelement(rtable,ch,k_wspace);
  1447.     for (p = CONST1; ch = *p++; )
  1448.     setelement(rtable,ch,k_const);
  1449.     for (p = CONST2; ch = *p++; )
  1450.     setelement(rtable,ch,k_const);
  1451.  
  1452.     /* install the read macros */
  1453.     defmacro('#', k_nmacro,rmhash);
  1454.     defmacro('\'',k_tmacro,rmquote);
  1455.     defmacro('"', k_tmacro,rmdquote);
  1456.     defmacro('`', k_tmacro,rmbquote);
  1457.     defmacro(',', k_tmacro,rmcomma);
  1458.     defmacro('(', k_tmacro,rmlpar);
  1459.     defmacro(')', k_tmacro,rmrpar);
  1460.     defmacro(';', k_tmacro,rmsemi);
  1461. }
  1462.  
  1463. SHAR_EOF
  1464. fi # end of overwriting check
  1465. if test -f 'xlstr.c'
  1466. then
  1467.     echo shar: will not over-write existing file "'xlstr.c'"
  1468. else
  1469. cat << \SHAR_EOF > 'xlstr.c'
  1470. /* xlstr - xlisp string builtin functions */
  1471. /*    Copyright (c) 1985, by David Michael Betz
  1472.     All Rights Reserved
  1473.     Permission is granted for unrestricted non-commercial use    */
  1474.  
  1475. #include "xlisp.h"
  1476.  
  1477. /* external variables */
  1478. extern NODE ***xlstack;
  1479. extern char buf[];
  1480.  
  1481. /* external procedures */
  1482. extern char *strcat();
  1483.  
  1484. /* xstrcat - concatenate a bunch of strings */
  1485. NODE *xstrcat(args)
  1486.   NODE *args;
  1487. {
  1488.     NODE ***oldstk,*val,*p;
  1489.     char *str;
  1490.     int len;
  1491.  
  1492.     /* create a new stack frame */
  1493.     oldstk = xlsave(&val,(NODE **)NULL);
  1494.  
  1495.     /* find the length of the new string */
  1496.     for (p = args, len = 0; p; )
  1497.     len += strlen(getstring(xlmatch(STR,&p)));
  1498.  
  1499.     /* create the result string */
  1500.     val = newstring(len);
  1501.     str = getstring(val);
  1502.     *str = 0;
  1503.  
  1504.     /* combine the strings */
  1505.     while (args)
  1506.     strcat(str,getstring(xlmatch(STR,&args)));
  1507.  
  1508.     /* restore the previous stack frame */
  1509.     xlstack = oldstk;
  1510.  
  1511.     /* return the new string */
  1512.     return (val);
  1513. }
  1514.  
  1515. /* xsubstr - return a substring */
  1516. NODE *xsubstr(args)
  1517.   NODE *args;
  1518. {
  1519.     NODE ***oldstk,*arg,*src,*val;
  1520.     int start,forlen,srclen;
  1521.     char *srcptr,*dstptr;
  1522.  
  1523.     /* create a new stack frame */
  1524.     oldstk = xlsave(&arg,&src,&val,(NODE **)NULL);
  1525.  
  1526.     /* initialize */
  1527.     arg = args;
  1528.     
  1529.     /* get string and its length */
  1530.     src = xlmatch(STR,&arg);
  1531.     srcptr = getstring(src);
  1532.     srclen = strlen(srcptr);
  1533.  
  1534.     /* get starting pos -- must be present */
  1535.     start = getfixnum(xlmatch(INT,&arg));
  1536.  
  1537.     /* get length -- if not present use remainder of string */
  1538.     forlen = (arg ? getfixnum(xlmatch(INT,&arg)) : srclen);
  1539.  
  1540.     /* make sure there aren't any more arguments */
  1541.     xllastarg(arg);
  1542.  
  1543.     /* don't take more than exists */
  1544.     if (start + forlen > srclen)
  1545.     forlen = srclen - start + 1;
  1546.  
  1547.     /* if start beyond string -- return null string */
  1548.     if (start > srclen) {
  1549.     start = 1;
  1550.     forlen = 0; }
  1551.     
  1552.     /* create return node */
  1553.     val = newstring(forlen);
  1554.     dstptr = getstring(val);
  1555.  
  1556.     /* move string */
  1557.     for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
  1558.     ;
  1559.     *dstptr = 0;
  1560.  
  1561.     /* restore the previous stack frame */
  1562.     xlstack = oldstk;
  1563.  
  1564.     /* return the substring */
  1565.     return (val);
  1566. }
  1567.  
  1568. /* xstring - return a string consisting of a single character */
  1569. NODE *xstring(args)
  1570.   NODE *args;
  1571. {
  1572.     /* get the character (integer) */
  1573.     buf[0] = getfixnum(xlmatch(INT,&args));
  1574.     xllastarg(args);
  1575.  
  1576.     /* make a one character string */
  1577.     buf[1] = 0;
  1578.     return (cvstring(buf));
  1579. }
  1580.  
  1581. /* xchar - extract a character from a string */
  1582. NODE *xchar(args)
  1583.   NODE *args;
  1584. {
  1585.     char *str;
  1586.     int n;
  1587.  
  1588.     /* get the string and the index */
  1589.     str = getstring(xlmatch(STR,&args));
  1590.     n = getfixnum(xlmatch(INT,&args));
  1591.     xllastarg(args);
  1592.  
  1593.     /* range check the index */
  1594.     if (n < 0 || n >= strlen(str))
  1595.     xlerror("index out of range",cvfixnum((FIXNUM)n));
  1596.  
  1597.     /* return the character */
  1598.     return (cvfixnum((FIXNUM)str[n]));
  1599. }
  1600.  
  1601. SHAR_EOF
  1602. fi # end of overwriting check
  1603. if test -f 'xlsubr.c'
  1604. then
  1605.     echo shar: will not over-write existing file "'xlsubr.c'"
  1606. else
  1607. cat << \SHAR_EOF > 'xlsubr.c'
  1608. /* xlsubr - xlisp builtin function support routines */
  1609. /*    Copyright (c) 1985, by David Michael Betz
  1610.     All Rights Reserved
  1611.     Permission is granted for unrestricted non-commercial use    */
  1612.  
  1613. #include "xlisp.h"
  1614.  
  1615. /* external variables */
  1616. extern NODE *k_test,*k_tnot,*s_eql;
  1617. extern NODE ***xlstack;
  1618.  
  1619. /* xlsubr - define a builtin function */
  1620. xlsubr(sname,type,subr)
  1621.   char *sname; int type; NODE *(*subr)();
  1622. {
  1623.     NODE *sym;
  1624.  
  1625.     /* enter the symbol */
  1626.     sym = xlsenter(sname);
  1627.  
  1628.     /* initialize the value */
  1629.     setvalue(sym,cvsubr(subr,type));
  1630. }
  1631.  
  1632. /* xlarg - get the next argument */
  1633. NODE *xlarg(pargs)
  1634.   NODE **pargs;
  1635. {
  1636.     NODE *arg;
  1637.  
  1638.     /* make sure the argument exists */
  1639.     if (!consp(*pargs))
  1640.     xlfail("too few arguments");
  1641.  
  1642.     /* get the argument value */
  1643.     arg = car(*pargs);
  1644.  
  1645.     /* move the argument pointer ahead */
  1646.     *pargs = cdr(*pargs);
  1647.  
  1648.     /* return the argument */
  1649.     return (arg);
  1650. }
  1651.  
  1652. /* xlmatch - get an argument and match its type */
  1653. NODE *xlmatch(type,pargs)
  1654.   int type; NODE **pargs;
  1655. {
  1656.     NODE *arg;
  1657.  
  1658.     /* get the argument */
  1659.     arg = xlarg(pargs);
  1660.  
  1661.     /* check its type */
  1662.     if (type == LIST) {
  1663.     if (arg && ntype(arg) != LIST)
  1664.         xlerror("bad argument type",arg);
  1665.     }
  1666.     else {
  1667.     if (arg == NIL || ntype(arg) != type)
  1668.         xlerror("bad argument type",arg);
  1669.     }
  1670.  
  1671.     /* return the argument */
  1672.     return (arg);
  1673. }
  1674.  
  1675. /* xlevarg - get the next argument and evaluate it */
  1676. NODE *xlevarg(pargs)
  1677.   NODE **pargs;
  1678. {
  1679.     NODE ***oldstk,*val;
  1680.  
  1681.     /* create a new stack frame */
  1682.     oldstk = xlsave(&val,(NODE **)NULL);
  1683.  
  1684.     /* get the argument */
  1685.     val = xlarg(pargs);
  1686.  
  1687.     /* evaluate the argument */
  1688.     val = xleval(val);
  1689.  
  1690.     /* restore the previous stack frame */
  1691.     xlstack = oldstk;
  1692.  
  1693.     /* return the argument */
  1694.     return (val);
  1695. }
  1696.  
  1697. /* xlevmatch - get an evaluated argument and match its type */
  1698. NODE *xlevmatch(type,pargs)
  1699.   int type; NODE **pargs;
  1700. {
  1701.     NODE *arg;
  1702.  
  1703.     /* get the argument */
  1704.     arg = xlevarg(pargs);
  1705.  
  1706.     /* check its type */
  1707.     if (type == LIST) {
  1708.     if (arg && ntype(arg) != LIST)
  1709.         xlerror("bad argument type",arg);
  1710.     }
  1711.     else {
  1712.     if (arg == NIL || ntype(arg) != type)
  1713.         xlerror("bad argument type",arg);
  1714.     }
  1715.  
  1716.     /* return the argument */
  1717.     return (arg);
  1718. }
  1719.  
  1720. /* xltest - get the :test or :test-not keyword argument */
  1721. void xltest(pfcn,ptresult,pargs)
  1722.   NODE **pfcn; int *ptresult; NODE **pargs;
  1723. {
  1724.     NODE *arg;
  1725.  
  1726.     /* default the argument to eql */
  1727.     if (!consp(*pargs)) {
  1728.     *pfcn = getvalue(s_eql);
  1729.     *ptresult = TRUE;
  1730.     return;
  1731.     }
  1732.  
  1733.     /* get the keyword */
  1734.     arg = car(*pargs);
  1735.  
  1736.     /* check the keyword */
  1737.     if (arg == k_test)
  1738.     *ptresult = TRUE;
  1739.     else if (arg == k_tnot)
  1740.     *ptresult = FALSE;
  1741.     else
  1742.     xlfail("expecting :test or :test-not");
  1743.  
  1744.     /* move the argument pointer ahead */
  1745.     *pargs = cdr(*pargs);
  1746.  
  1747.     /* make sure the argument exists */
  1748.     if (!consp(*pargs))
  1749.     xlfail("no value for keyword argument");
  1750.  
  1751.     /* get the argument value */
  1752.     *pfcn = car(*pargs);
  1753.  
  1754.     /* if its a symbol, get its value */
  1755.     if (symbolp(*pfcn))
  1756.     *pfcn = xleval(*pfcn);
  1757.  
  1758.     /* move the argument pointer ahead */
  1759.     *pargs = cdr(*pargs);
  1760. }
  1761.  
  1762. /* xlgetfile - get a file or stream */
  1763. NODE *xlgetfile(pargs)
  1764.   NODE **pargs;
  1765. {
  1766.     NODE *arg;
  1767.  
  1768.     /* get a file or stream (cons) or nil */
  1769.     if (arg = xlarg(pargs)) {
  1770.     if (filep(arg)) {
  1771.         if (arg->n_fp == NULL)
  1772.         xlfail("file not open");
  1773.     }
  1774.     else if (!consp(arg))
  1775.         xlerror("bad argument type",arg);
  1776.     }
  1777.     return (arg);
  1778. }
  1779.  
  1780. /* xllastarg - make sure the remainder of the argument list is empty */
  1781. xllastarg(args)
  1782.   NODE *args;
  1783. {
  1784.     if (args)
  1785.     xlfail("too many arguments");
  1786. }
  1787.  
  1788. /* eq - internal eq function */
  1789. int eq(arg1,arg2)
  1790.   NODE *arg1,*arg2;
  1791. {
  1792.     return (arg1 == arg2);
  1793. }
  1794.  
  1795. /* eql - internal eql function */
  1796. int eql(arg1,arg2)
  1797.   NODE *arg1,*arg2;
  1798. {
  1799.     if (eq(arg1,arg2))
  1800.     return (TRUE);
  1801.     else if (fixp(arg1) && fixp(arg2))
  1802.     return (arg1->n_int == arg2->n_int);
  1803.     else if (floatp(arg1) && floatp(arg2))
  1804.     return (arg1->n_float == arg2->n_float);
  1805.     else if (stringp(arg1) && stringp(arg2))
  1806.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  1807.     else
  1808.     return (FALSE);
  1809. }
  1810.  
  1811. /* equal - internal equal function */
  1812. int equal(arg1,arg2)
  1813.   NODE *arg1,*arg2;
  1814. {
  1815.     /* compare the arguments */
  1816.     if (eql(arg1,arg2))
  1817.     return (TRUE);
  1818.     else if (consp(arg1) && consp(arg2))
  1819.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  1820.     else
  1821.     return (FALSE);
  1822. }
  1823.  
  1824. SHAR_EOF
  1825. fi # end of overwriting check
  1826. if test -f 'xlsym.c'
  1827. then
  1828.     echo shar: will not over-write existing file "'xlsym.c'"
  1829. else
  1830. cat << \SHAR_EOF > 'xlsym.c'
  1831. /* xlsym - symbol handling routines */
  1832. /*    Copyright (c) 1985, by David Michael Betz
  1833.     All Rights Reserved
  1834.     Permission is granted for unrestricted non-commercial use    */
  1835.  
  1836. #include "xlisp.h"
  1837.  
  1838. /* external variables */
  1839. extern NODE *obarray,*s_unbound,*self;
  1840. extern NODE ***xlstack,*xlenv;
  1841.  
  1842. /* forward declarations */
  1843. FORWARD NODE *findprop();
  1844.  
  1845. /* xlenter - enter a symbol into the obarray */
  1846. NODE *xlenter(name,type)
  1847.   char *name; int type;
  1848. {
  1849.     NODE ***oldstk,*sym,*array;
  1850.     int i;
  1851.  
  1852.     /* check for nil */
  1853.     if (strcmp(name,"NIL") == 0)
  1854.     return (NIL);
  1855.  
  1856.     /* check for symbol already in table */
  1857.     array = getvalue(obarray);
  1858.     i = hash(name,HSIZE);
  1859.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  1860.     if (strcmp(name,getstring(getpname(car(sym)))) == 0)
  1861.         return (car(sym));
  1862.  
  1863.     /* make a new symbol node and link it into the list */
  1864.     oldstk = xlsave(&sym,(NODE **)NULL);
  1865.     sym = consd(getelement(array,i));
  1866.     rplaca(sym,xlmakesym(name,type));
  1867.     setelement(array,i,sym);
  1868.     xlstack = oldstk;
  1869.  
  1870.     /* return the new symbol */
  1871.     return (car(sym));
  1872. }
  1873.  
  1874. /* xlsenter - enter a symbol with a static print name */
  1875. NODE *xlsenter(name)
  1876.   char *name;
  1877. {
  1878.     return (xlenter(name,STATIC));
  1879. }
  1880.  
  1881. /* xlmakesym - make a new symbol node */
  1882. NODE *xlmakesym(name,type)
  1883.   char *name;
  1884. {
  1885.     NODE *sym;
  1886.     sym = (type == DYNAMIC ? cvsymbol(name) : cvcsymbol(name));
  1887.     setvalue(sym,*name == ':' ? sym : s_unbound);
  1888.     return (sym);
  1889. }
  1890.  
  1891. /* xlframe - create a new environment frame */
  1892. NODE *xlframe(env)
  1893.   NODE *env;
  1894. {
  1895.     return (consd(env));
  1896. }
  1897.  
  1898. /* xlbind - bind a value to a symbol */
  1899. xlbind(sym,val,env)
  1900.   NODE *sym,*val,*env;
  1901. {
  1902.     NODE *ptr;
  1903.  
  1904.     /* create a new environment list entry */
  1905.     ptr = consd(car(env));
  1906.     rplaca(env,ptr);
  1907.  
  1908.     /* create a new variable binding */
  1909.     rplaca(ptr,cons(sym,val));
  1910. }
  1911.  
  1912. /* xlgetvalue - get the value of a symbol (checked) */
  1913. NODE *xlgetvalue(sym)
  1914.   NODE *sym;
  1915. {
  1916.     register NODE *val;
  1917.     while ((val = xlxgetvalue(sym)) == s_unbound)
  1918.     xlunbound(sym);
  1919.     return (val);
  1920. }
  1921.  
  1922. /* xlxgetvalue - get the value of a symbol */
  1923. NODE *xlxgetvalue(sym)
  1924.   NODE *sym;
  1925. {
  1926.     register NODE *fp,*ep;
  1927.     NODE *val;
  1928.  
  1929.     /* check for this being an instance variable */
  1930.     if (getvalue(self) && xlobgetvalue(sym,&val))
  1931.     return (val);
  1932.  
  1933.     /* check the environment list */
  1934.     for (fp = xlenv; fp; fp = cdr(fp))
  1935.     for (ep = car(fp); ep; ep = cdr(ep))
  1936.         if (sym == car(car(ep)))
  1937.         return (cdr(car(ep)));
  1938.  
  1939.     /* return the global value */
  1940.     return (getvalue(sym));
  1941. }
  1942.  
  1943. /* xlygetvalue - get the value of a symbol (no instance variables) */
  1944. NODE *xlygetvalue(sym)
  1945.   NODE *sym;
  1946. {
  1947.     register NODE *fp,*ep;
  1948.  
  1949.     /* check the environment list */
  1950.     for (fp = xlenv; fp; fp = cdr(fp))
  1951.     for (ep = car(fp); ep; ep = cdr(ep))
  1952.         if (sym == car(car(ep)))
  1953.         return (cdr(car(ep)));
  1954.  
  1955.     /* return the global value */
  1956.     return (getvalue(sym));
  1957. }
  1958.  
  1959. /* xlsetvalue - set the value of a symbol */
  1960. void xlsetvalue(sym,val)
  1961.   NODE *sym,*val;
  1962. {
  1963.     register NODE *fp,*ep;
  1964.  
  1965.     /* check for this being an instance variable */
  1966.     if (getvalue(self) && xlobsetvalue(sym,val))
  1967.     return;
  1968.  
  1969.     /* look for the symbol in the environment list */
  1970.     for (fp = xlenv; fp; fp = cdr(fp))
  1971.     for (ep = car(fp); ep; ep = cdr(ep))
  1972.         if (sym == car(car(ep))) {
  1973.         rplacd(car(ep),val);
  1974.         return;
  1975.         }
  1976.  
  1977.     /* store the global value */
  1978.     setvalue(sym,val);
  1979. }
  1980.  
  1981. /* xlgetprop - get the value of a property */
  1982. NODE *xlgetprop(sym,prp)
  1983.   NODE *sym,*prp;
  1984. {
  1985.     NODE *p;
  1986.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  1987. }
  1988.  
  1989. /* xlputprop - put a property value onto the property list */
  1990. xlputprop(sym,val,prp)
  1991.   NODE *sym,*val,*prp;
  1992. {
  1993.     NODE ***oldstk,*p,*pair;
  1994.     if ((pair = findprop(sym,prp)) == NIL) {
  1995.     oldstk = xlsave(&p,(NODE **)NULL);
  1996.     p = consa(prp);
  1997.     rplacd(p,pair = cons(val,getplist(sym)));
  1998.     setplist(sym,p);
  1999.     xlstack = oldstk;
  2000.     }
  2001.     rplaca(pair,val);
  2002. }
  2003.  
  2004. /* xlremprop - remove a property from a property list */
  2005. xlremprop(sym,prp)
  2006.   NODE *sym,*prp;
  2007. {
  2008.     NODE *last,*p;
  2009.     last = NIL;
  2010.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  2011.     if (car(p) == prp)
  2012.         if (last)
  2013.         rplacd(last,cdr(cdr(p)));
  2014.         else
  2015.         setplist(sym,cdr(cdr(p)));
  2016.     last = cdr(p);
  2017.     }
  2018. }
  2019.  
  2020. /* findprop - find a property pair */
  2021. LOCAL NODE *findprop(sym,prp)
  2022.   NODE *sym,*prp;
  2023. {
  2024.     NODE *p;
  2025.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  2026.     if (car(p) == prp)
  2027.         return (cdr(p));
  2028.     return (NIL);
  2029. }
  2030.  
  2031. /* hash - hash a symbol name string */
  2032. int hash(str,len)
  2033.   char *str;
  2034. {
  2035.     int i;
  2036.     for (i = 0; *str; )
  2037.     i = (i << 2) ^ *str++;
  2038.     i %= len;
  2039.     return (abs(i));
  2040. }
  2041.  
  2042. /* xlsinit - symbol initialization routine */
  2043. xlsinit()
  2044. {
  2045.     NODE *array,*p;
  2046.  
  2047.     /* initialize the obarray */
  2048.     obarray = xlmakesym("*OBARRAY*",STATIC);
  2049.     array = newvector(HSIZE);
  2050.     setvalue(obarray,array);
  2051.  
  2052.     /* add the symbol *OBARRAY* to the obarray */
  2053.     p = consa(obarray);
  2054.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  2055.  
  2056.     /* enter the unbound symbol indicator */
  2057.     s_unbound = xlsenter("*UNBOUND*");
  2058.     setvalue(s_unbound,s_unbound);
  2059. }
  2060.  
  2061. SHAR_EOF
  2062. fi # end of overwriting check
  2063. if test -f 'xlsys.c'
  2064. then
  2065.     echo shar: will not over-write existing file "'xlsys.c'"
  2066. else
  2067. cat << \SHAR_EOF > 'xlsys.c'
  2068. /* xlsys.c - xlisp builtin system functions */
  2069. /*    Copyright (c) 1985, by David Michael Betz
  2070.     All Rights Reserved
  2071.     Permission is granted for unrestricted non-commercial use    */
  2072.  
  2073. #include "xlisp.h"
  2074.  
  2075. /* external variables */
  2076. extern NODE ***xlstack,*xlenv;
  2077. extern int anodes;
  2078.  
  2079. /* external symbols */
  2080. extern NODE *a_subr,*a_fsubr;
  2081. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
  2082. extern NODE *true;
  2083.  
  2084. /* xload - direct input from a file */
  2085. NODE *xload(args)
  2086.   NODE *args;
  2087. {
  2088.     NODE ***oldstk,*fname,*val;
  2089.     int vflag,pflag;
  2090.     char *name;
  2091.  
  2092.     /* create a new stack frame */
  2093.     oldstk = xlsave(&fname,(NODE **)NULL);
  2094.  
  2095.     /* get the file name, verbose flag and print flag */
  2096.     fname = xlarg(&args);
  2097.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  2098.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  2099.     xllastarg(args);
  2100.  
  2101.     /* get the filename string */
  2102.     if (symbolp(fname))
  2103.     name = getstring(getpname(fname));
  2104.     else if (stringp(fname))
  2105.     name = getstring(fname);
  2106.     else
  2107.     xlfail("bad argument type",fname);
  2108.  
  2109.     /* load the file */
  2110.     val = (xlload(name,vflag,pflag) ? true : NIL);
  2111.  
  2112.     /* restore the previous stack frame */
  2113.     xlstack = oldstk;
  2114.  
  2115.     /* return the status */
  2116.     return (val);
  2117. }
  2118.  
  2119. /* xgc - xlisp function to force garbage collection */
  2120. NODE *xgc(args)
  2121.   NODE *args;
  2122. {
  2123.     /* make sure there aren't any arguments */
  2124.     xllastarg(args);
  2125.  
  2126.     /* garbage collect */
  2127.     gc();
  2128.  
  2129.     /* return nil */
  2130.     return (NIL);
  2131. }
  2132.  
  2133. /* xexpand - xlisp function to force memory expansion */
  2134. NODE *xexpand(args)
  2135.   NODE *args;
  2136. {
  2137.     int n,i;
  2138.  
  2139.     /* get the new number to allocate */
  2140.     n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
  2141.     xllastarg(args);
  2142.  
  2143.     /* allocate more segments */
  2144.     for (i = 0; i < n; i++)
  2145.     if (!addseg())
  2146.         break;
  2147.  
  2148.     /* return the number of segments added */
  2149.     return (cvfixnum((FIXNUM)i));
  2150. }
  2151.  
  2152. /* xalloc - xlisp function to set the number of nodes to allocate */
  2153. NODE *xalloc(args)
  2154.   NODE *args;
  2155. {
  2156.     int n,oldn;
  2157.  
  2158.     /* get the new number to allocate */
  2159.     n = getfixnum(xlmatch(INT,&args));
  2160.  
  2161.     /* make sure there aren't any more arguments */
  2162.     xllastarg(args);
  2163.  
  2164.     /* set the new number of nodes to allocate */
  2165.     oldn = anodes;
  2166.     anodes = n;
  2167.  
  2168.     /* return the old number */
  2169.     return (cvfixnum((FIXNUM)oldn));
  2170. }
  2171.  
  2172. /* xmem - xlisp function to print memory statistics */
  2173. NODE *xmem(args)
  2174.   NODE *args;
  2175. {
  2176.     /* make sure there aren't any arguments */
  2177.     xllastarg(args);
  2178.  
  2179.     /* print the statistics */
  2180.     stats();
  2181.  
  2182.     /* return nil */
  2183.     return (NIL);
  2184. }
  2185.  
  2186. /* xtype - return type of a thing */
  2187. NODE *xtype(args)
  2188.     NODE *args;
  2189. {
  2190.     NODE *arg;
  2191.  
  2192.     if (!(arg = xlarg(&args)))
  2193.     return (NIL);
  2194.  
  2195.     switch (ntype(arg)) {
  2196.     case SUBR:    return (a_subr);
  2197.     case FSUBR:    return (a_fsubr);
  2198.     case LIST:    return (a_list);
  2199.     case SYM:    return (a_sym);
  2200.     case INT:    return (a_int);
  2201.     case FLOAT:    return (a_float);
  2202.     case STR:    return (a_str);
  2203.     case OBJ:    return (a_obj);
  2204.     case FPTR:    return (a_fptr);
  2205.     case VECT:    return (a_vect);
  2206.     default:    xlfail("bad node type");
  2207.     }
  2208.     /*NOTREACHED*/
  2209. }
  2210.  
  2211. /* xbaktrace - print the trace back stack */
  2212. NODE *xbaktrace(args)
  2213.   NODE *args;
  2214. {
  2215.     int n;
  2216.  
  2217.     n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
  2218.     xllastarg(args);
  2219.     xlbaktrace(n);
  2220.     return (NIL);
  2221. }
  2222.  
  2223. /* xexit - get out of xlisp */
  2224. NODE *xexit(args)
  2225.   NODE *args;
  2226. {
  2227.     xllastarg(args);
  2228.     osfinish ();
  2229.     exit(0);
  2230. }
  2231.  
  2232. SHAR_EOF
  2233. fi # end of overwriting check
  2234. #    End of shell archive
  2235. exit 0
  2236.